COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00003 00003	! mssngr buffer procedures: getfp,getfpa,getin,getina 
C00004 00004	! unfixment,affixment,move,rforce,array_parameters
C00009 00005	! $execute,$elfeval,$$gtvexpr,$$gtexpr
C00018 ENDMK
C⊗;
ENTRY;
BEGIN "EXEC"
DEFINE $$PRGID=TRUE;	DEFINE $EXEC=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;

! mssngr buffer procedures: getfp,getfpa,getin,getina ;

SIMPLE REAL PROCEDURE GETFP;
	RETURN($FPBUF[$FPPTR←$FPPTR+1]);

SIMPLE PROCEDURE GETFPA(REAL ARRAY A; INTEGER NDATA);
	BEGIN
	ARRBLT(A[1],$FPBUF[$FPPTR+1],NDATA);
	$FPPTR←$FPPTR+NDATA;
	END;

INTERNAL SIMPLE INTEGER PROCEDURE GETIN;
	RETURN($INBUF[$INTPTR←$INTPTR+1]);

SIMPLE PROCEDURE GETINA(INTEGER ARRAY A; INTEGER NDATA);
	BEGIN
	ARRBLT(A[1],$INBUF[$INTPTR+1],NDATA);
	$INTPTR←$INTPTR+NDATA;
	END;
! unfixment,affixment,move,rforce,array_parameters;

RPTR(FRAME)PROCEDURE GTFRMPTR(STRING MESS);
	BEGIN
	INTEGER I,DIM;
	RPTR(SYMBOL)S;
	RPTR(FRAME)F;
	I←GETIN;
	DIM←ARRYDIM(I,S);
	IF S AND SYMBOL:TYPE[S]≠#FR THEN ERROR(MESS);
	IF DIM THEN
		BEGIN
		INTEGER ARRAY ARR[1:DIM];
		GETINA(ARR,DIM);
		F←GTFRAME(I,DIM,ARR,S);
		END
	ELSE IF S THEN F←SYMBOL:OBJECT[S] ELSE RETURN(NULL_RECORD);
	RETURN(F);
	END;

PROCEDURE UNFIXMENT;
	BEGIN
	RPTR(FRAME)F1,F2;
	F1←GTFRMPTR("Unfixment of nonexistent frame");
	F2←GTFRMPTR("Unfixment from nonexistent frame");
	IF (F1≠NULL_RECORD) AND (F2≠NULL_RECORD) THEN UFX_NODE(F1,F2);
	$FRLST←NULL;
	END;

PROCEDURE AFFIXMENT;
	BEGIN
	RPTR(FRAME)F1,F2; INTEGER AFFTYP;
	F1←GTFRMPTR("AFFIXMENT OF NONEXISTENT FRAME");
	F2←GTFRMPTR("AFFIXMENT FROM NONEXISTENT FRAME");
	AFFTYP←GETIN;
	IF AFFTYP LAND #NONRGD THEN AFFTYP←#NRGLK ELSE AFFTYP←#RGDLK;
	IF (F1≠NULL_RECORD) AND (F2≠NULL_RECORD) THEN AFX_NODE(F1,F2,AFFTYP);
	$FRLST←NULL;
	END;

SIMPLE INTEGER PROCEDURE COUNTBITS(INTEGER BITS);
	BEGIN INTEGER I,J,K;
	I←0;
	J←BITS LAND '177777;
	FOR K←1 STEP 1 UNTIL 16 DO
		BEGIN
		I←I + (J LAND 1);
		J←J LSH -1;
		END;
	RETURN(I);
	END;

PROCEDURE MOVE;
BEGIN	INTEGER CODE,SIZE,BITS,PNTS;
	BITS←GETIN;
	PNTS←GETIN;
	SIZE←COUNTBITS(BITS)*PNTS;
	IF SIZE>0 THEN
	    BEGIN
	    REAL ARRAY A[1:SIZE];
	    RPTR(GRAPHREC) G;
	    G←NEW_RECORD(GRAPHREC);
	    GRAPHREC:CTLBITS[G]←BITS;
	    GRAPHREC:NPNTS[G]←PNTS;
	    GRAPHREC:SIZE[G]←SIZE;
	    GETFPA(A,SIZE);
	    MEMORY[LOCATION(GRAPHREC:DATA[G])]↔MEMORY[LOCATION(A)];
	    GRAPTR←G;
	    END;
END;

PROCEDURE RFORCE;
	BEGIN INTEGER ARRAY DAT[1:10,1:9],DATA[1:90];
	GETINA(DATA,90);
	ARRBLT(DAT[1,1],DATA[1],90);
	WSTPTR←NEW_RECORD(WRISTREC);
	MEMORY[LOCATION(WRISTREC:DATA[WSTPTR])]↔MEMORY[LOCATION(DAT)];
	END;

! constructs the insides of the ARRAYREC record;
PROCEDURE ARRAY_PARAMETERS;
BEGIN
RPTR(ARRAYREC)SYMOBJ;
RPTR(SYMBOL)SYM;
INTEGER #DIM,#EL,OFFSET;
OFFSET←GETIN;
#EL←GETIN;
#DIM←GETIN;
	BEGIN
	INTEGER I,DIM;
	INTEGER ARRAY UB,LB,MULT[1:5];
	FOR I←1 STEP 1 UNTIL #DIM DO
		BEGIN UB[I]←GETIN;LB[I]←GETIN;
			MULT[I]←GETIN; END;
	DIM←ARRYDIM(OFFSET,SYM);
	IF SYM=NULL_RECORD THEN RETURN
	    ELSE IF SYMBOL:ACCESS[SYM]≠#ARRAY THEN ERROR("ERROR in ARRAY_PARAMETERS")
	    ELSE BEGIN
		SYMOBJ←SYMBOL:OBJECT[SYM];
		IF #DIM≠DIM THEN ERROR("ERROR IN ARRAY_PARAMETERS: incompatible number of dimensions");
		IF ARRAYREC:#EL[SYMOBJ]=0
			THEN NWAREC(SYM,#EL,LB,UB,MULT,SYMBOL:DIMENS[SYM]);
		END;
	END;
END;
! $execute,$elfeval,$$gtvexpr,$$gtexpr;

RPTR(EXPR$) PROCEDURE $RAPPEND(RPTR(RSTACK)R);
IF RSTACK:TOP[R]=0 THEN RETURN(NULL_RECORD) ELSE
	BEGIN
	RTRIM(R);
	RETURN($AAPPEND(RSTACK:STACK[R]));
	END;

INTERNAL PROCEDURE BUFFERUSAGE(STRING S);
	BEGIN
	STRING S1;
	IF $NOELF OR $ELFUNAVAILABLE THEN RETURN;
	S1←NULL;
	IF $INTPTR≠$INTSIZ THEN
		S1←"$INTPTR="&CVS($INTPTR)&":$INTSIZ="&CVS($INTSIZ)&" in "&S&CRLF;
	IF $FPPTR≠$FPSIZ THEN
		S1←S1&"$FPPTR="&CVS($FPPTR)&":$FPSIZ="&CVS($FPSIZ)&" in "&S&CRLF;
	IF S1 THEN ERROR(S1);
	END;


PROCEDURE FILREC(RANY S; INTEGER TYPE);
	CASE TYPE OF
		BEGIN
		[#SC]	SCALAR:VALUE[S]←GETFP;
		[#VT]	BEGIN
			VECTOR:XC[S]←GETFP;
			VECTOR:YC[S]←GETFP;
			VECTOR:ZC[S]←GETFP;
			END;
		[#RT]	GETFPA(ROT:XF[S],6);
		[#TR]	GETFPA(TRANS:XF[S],6);
		[#FR]	GETFPA(FRAME:XF[S],6);
		ELSE ERROR("error in $EVLARR")
		END;

INTERNAL PROCEDURE $EVLARR(RPTR(SYMBOL)SYM);
BEGIN
RPTR(EXPR$)E; RPTR(ARRAYREC)SYMOBJ;
INTEGER #EL,i;
IF SYMBOL:ACCESS[SYM]≠#ARRAY THEN ERROR("$EVLARR error: non array symbol");
E←EXPR$3(XRTARR,SYMBOL:OFFSET[SYM],XPDONE);
EVAL(E);
SYMOBJ←SYMBOL:OBJECT[SYM];
#EL←GETIN;
IF ARRAYREC:#EL[SYMOBJ]≠#EL THEN ERROR("$EVLARR error in array size");
FOR I←1 STEP 1 UNTIL #EL DO
	BEGIN RANY S;
	S←SYMBOL:OBJECT[ARRAYREC:PTR[SYMOBJ][I]];
	FILREC(S,SYMBOL:TYPE[S]);
	END;
BUFFERUSAGE("$EVLARR");
END;

RPTR(EXPR$) PROCEDURE EVAL110(RPTR(SYMBOL)SYM);
	IF SYMBOL:TYPE[SYM]≠#FR THEN
		RETURN(EXPR$R(SYM))
	ELSE BEGIN
		RPTR(FRAME)D,S;
		RPTR(SYMBOL)DADSYM,SONSYM;
		SONSYM←SYM;
		S←SYMBOL:OBJECT[SONSYM];
		D←FRAME:DAD[S];
		DADSYM←FRAME:SYM[D];
		IF D=F_WRLD THEN
			RETURN(EXPR$R(SONSYM))
			ELSE
			BEGIN
			RPTR(EXPR$) ARRAY P[1:4];
			P[1]←EXPR$G(DADSYM);
			P[2]←EXPR$1(XTINVRT);
			P[3]←EXPR$G(SONSYM);
			P[4]←EXPR$2(XTTMUL,XRTVAL);
			RETURN($AAPPEND(P));
			END;
		END;

INTERNAL RANY PROCEDURE $EVAL11(RPTR(SYMBOL)SYM);
	BEGIN	! update value of given symbol ;
	RPTR(EXPR$) PPTR; RANY S;
	RPTR(EXPR$)E;
	S←SYMBOL:OBJECT[SYM];
	PPTR←EVAL110(SYM);
	E←$APPEND(PPTR,EXPR$1(XPDONE));
	EVAL(E);
	FILREC(S,SYMBOL:TYPE[SYM]);
	BUFFERUSAGE("$EVAL11");
	RETURN(S);
	END;

PROCEDURE UDATFRAME;
	BEGIN
	INTEGER I,N; RPTR(FRAME)D; RPTR(EXPR$)ELFX;
	RPTR(RSTACK)SLIST,SYLIST;

	RECURSIVE PROCEDURE FRTREE(RPTR(FRAME)ND);
		BEGIN
		RPUSH(SLIST,EVAL110(FRAME:SYM[ND]));
		RPUSH(SYLIST,SYMBOL:OBJECT[FRAME:SYM[ND]]);
		ND←FRAME:SON[ND];
		WHILE ND≠NULL_RECORD DO
			BEGIN
			FRTREE(ND); ND←FRAME:EBRO[ND];
			END;
		END;

	SLIST←NEW_RSTACK;SYLIST←NEW_RSTACK;
	D←FRAME:SON[F_WRLD];
	WHILE D≠NULL_RECORD DO
		BEGIN FRTREE(D); D←FRAME:EBRO[D]; END;
	ELFX←$APPEND($RAPPEND(SLIST),EXPR$1(XPDONE));
	EVAL(ELFX);
	N←RSIZE(SYLIST);
	FOR I←1 STEP 1 UNTIL N DO FILREC(RSTACK:STACK[SYLIST][I],#FR);
	BUFFERUSAGE("UDATFRAMES");
	END;

INTERNAL PROCEDURE UDATVAR(INTEGER TYPE);
	IF TYPE=#FR THEN UDATFRAME ELSE
	BEGIN	RPTR(EXPR$)ELFX;
	RPTR(RSTACK)SLIST,SYLIST;
	INTEGER I,N; RPTR(SYMBOL)ADDR;
	    SLIST←NEW_RSTACK; SYLIST←NEW_RSTACK;
	    FOR I←1 STEP 1 UNTIL $ENTRY[TYPE] DO
	    IF ((ADDR←$YMPTR(TYPE,I))≠NULL_RECORD)
		AND (SYMBOL:ACCESS[ADDR]=#SIMPLE)
		AND ((SYMBOL:OFFSET[ADDR]<'400)
		OR (SYMBOL:INDEX[ADDR] ≥ OFFSET[ARM_OFFSET,TYPE]))
		AND TYPE≠#MC AND TYPE≠#PR
	       THEN
		BEGIN RPUSH(SLIST,EVAL110(ADDR));
		      RPUSH(SYLIST,SYMBOL:OBJECT[ADDR]);
		END;
	   ELFX←$APPEND($RAPPEND(SLIST),EXPR$1(XPDONE));
	   EVAL(ELFX);
	   N←RSIZE(SYLIST);
	   FOR I←1 STEP 1 UNTIL N DO FILREC(RSTACK:STACK[SYLIST][I],TYPE);
	   BUFFERUSAGE("UDATVAR");
	END;

INTERNAL PROCEDURE UDATSYMS(RPTR(SYMREC_LIST)DISPLAY_LIST);
	BEGIN INTEGER N,I; RPTR(SYMBOL)S;
	RPTR(EXPR$)ELFX;
	RPTR(RSTACK)SLIST,SYLIST;
	RPTR(SYMREC_LIST)SL;
	SLIST←NEW_RSTACK;SYLIST←NEW_RSTACK;
	SL←DISPLAY_LIST;
	WHILE SL≠NULL_RECORD
		DO BEGIN
		IF NOT(SYMBOL:TYPE[S←SYMREC_LIST:PTR[SL]]=#MC
		   OR SYMBOL:TYPE[S]=#PR OR SYMBOL:ACCESS[S]=#PROCEDURE)
		   THEN BEGIN
			RPUSH(SLIST,EVAL110(S←SYMREC_LIST:PTR[SL]));
			RPUSH(SYLIST,S);
			END;
		SL←SYMREC_LIST:NEXT[SL];
		END;
	ELFX←$APPEND($RAPPEND(SLIST),EXPR$1(XPDONE));
	EVAL(ELFX);
	N←RSIZE(SYLIST);
	FOR I←1 STEP 1 UNTIL N DO FILREC(SYMBOL:OBJECT[S←RSTACK:STACK[SYLIST][I]],
		SYMBOL:TYPE[S]);
	BUFFERUSAGE("UDATSYMS");
	END;

INTERNAL RANY PROCEDURE $EVALEXP(RPTR(EXPR$)EX);
	BEGIN ! ex is of the form returned by idref;
	RANY S; INTEGER TY;
	RPTR(EXPR$)E;
	S←MK_REC(TY←EXPR$:TYPE[EX]);
	E←$APPEND(EX,EXPR$3(XGVALS,XRTVAL,XPDONE));
	EVAL(E);
	FILREC(S,TY);
	BUFFERUSAGE("$EVALEXP");
	RETURN(S);
	END;

INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $ELFEVAL(RPTR(EXPR$)CUEXPR);
	BEGIN
	RPTR(EXPR$)ELFX;
	IF RTN10 THEN CUEXPR←$APPEND(EXPR$3(XPHALT,0,1),CUEXPR);
	ELFX←$APPEND(CUEXPR,EXPR$1(XPDONE));
	EVAL(ELFX);
	RETURN(ELFX);
	END;

INTERNAL PROCEDURE TENINTERPRET;
	CASE GETIN OF
		BEGIN
		[XPHALT] PBREAK;
		[XMOVE] MOVE;
		[XRFORCE] RFORCE;
		[XAFFIX] AFFIXMENT;
		[XUNFIX] UNFIXMENT;
		[XRTPARS] ARRAY_PARAMETERS;
		ELSE ERROR("unexpected value in control buffer")
		END;

INTERNAL RECURSIVE PROCEDURE $EXECUTE(RPTR(EXPR$)CUEXPR);
	BEGIN
	IF !PPCODE THEN PPCODE(CUEXPR);
	IF !PWCODE THEN PWCODE(CUEXPR);
	$ELFEVAL(CUEXPR);	! evaluate the expression on the ELF;
	WHILE $INTPTR<$INTSIZ DO TENINTERPRET;
	BUFFERUSAGE("$EXECUTE");
	END;


INTERNAL PROCEDURE TEXEC;
	BEGIN
	READBUFFERS("TGRAPH");
	WHILE $INTPTR<$INTSIZ DO TENINTERPRET;
	BUFFERUSAGE("TGRAPH");
	ZROBUFF;		! zeroes the buffers in the 11 ;
	END;

END "EXEC";